home *** CD-ROM | disk | FTP | other *** search
/ Aminet 39 / Aminet 39 (2000)(Schatztruhe)[!][Oct 2000].iso / Aminet / dev / basic / ImageDTInfo.lha / ImageDTInfo / AuxRoutines / InfoImgFile.bas < prev   
Encoding:
BASIC Source File  |  2000-08-18  |  9.4 KB  |  280 lines
  1. ' ------------------------------------------------------------------------
  2. '                Identifying a graphic file and obtaining
  3. '    some info needed about it via custom routine/OS datatypes system
  4. '                                ------------
  5. '                   Identificación de un fichero gráfico 
  6. '        y  devolución de la información que necesitamos sobre él.
  7. ' ------------------------------------------------------------------------
  8. ' Arguments/Argumentos
  9. '
  10. ' fich$ = Nombre del fichero (formato AmigaDOS
  11. '         como por ejemplo "SYS:Img/Ejemplo.png")
  12. '
  13. '         Filename (AmigaDOS format like "SYS:Img/Ejemplo.png")
  14. '
  15. ' Returned/Devuelve...
  16. '
  17. '         O una cadena nula (problemas con el fichero) o una
  18. '         cadena con el formato "<FORMATO> - <ancho> x <alto> x <planos>"
  19. '
  20. '         Or a null string (troubles with the file) OR an
  21. '         string with the format "<FORMAT> - <width> x <height> x <depth>"
  22. ' ------------------------------------------------------------------------
  23.  
  24. ' ----------------------------------------
  25. ' REM $include dos.bh
  26. ' REM $include datatypes.bh
  27. ' REM $include datatypes/pictureclass.bc
  28. ' REM $include datatypes/datatypesclass.bc
  29. ' ----------------------------------------
  30.  
  31. FUNCTION InfoImgFile$(fich$)
  32. SHARED en&,em$
  33. LOCAL  o&,b&,d&,tags&
  34. LOCAL  a%,d%,char&,tmp$,c$
  35.  
  36.     ' - Initial hypothesis: the routine fails -
  37.     ' -- Hipótesis inicial: la rutina falla ---
  38.     ' -----------------------------------------
  39.     InfoImgFile$=""
  40.  
  41.     ' ------------------------------------------------------------------------
  42.     '                     Checking is an file is a PNG image...
  43.     '            and obtaining the height, width and depth color info.
  44.     '                For more info about the PNG 1.2 specification...
  45.     '                     http://www.w3.org/TR/REC-png.txt.gz
  46.     '                 "Asked" by Mr Goertz for ImageDTInfo :)...
  47.     '                                ------------
  48.     '                Verificando si un fichero es una imagen PNG...
  49.     '   y obtención en ese caso de su altura, anchura y nº de planos de color.
  50.     '             Para más información sobre el formato PNG 1.2...
  51.     '         PNG (Portable Network Graphics) Specification, Version 1.2
  52.     '                  http://www.w3.org/TR/REC-png.txt.gz
  53.     '            "Pedido" por el Sr. Goertz para ImageDTInfo :)...
  54.     ' ------------------------------------------------------------------------
  55.  
  56.     ' ---- This avoid to fail the Basic string functions -----
  57.     ' - Evita que falle las funciones de cadena del Basic ;) -
  58.     ' --------------------------------------------------------
  59.     c$=STRING$(25,CHR$(0))
  60.  
  61.     ' -- I read from the (image) file the first 25 bytes... --
  62.     ' ---- Se leen los 25 primeros octetos del fichero... ----
  63.     ' --------------------------------------------------------
  64.     IF FEXISTS(fich$) THEN
  65.         IF RIGHT$(fich$,1)=":" OR RIGHT$(fich$,1)="/" THEN 
  66.             em$ = CadLc$(ERROR_FILE_NOT_FOUND&)
  67.         ELSE
  68.             OPEN fich$ FOR INPUT AS #1
  69.                 IF LOF(1)>=25 THEN c$=INPUT$(25,#1)
  70.             CLOSE #1
  71.         END IF
  72.     ELSE
  73.         em$ = CadLc$(ERROR_FILE_NOT_FOUND&)
  74.     END IF
  75.  
  76.     ' ------- I verify what the 8 first bytes are equal ---------
  77.     ' --- to PNG signature and the IDHR chunk is the first. -----
  78.  
  79.     ' --- Se comprueba que los 8 primeros octetos coinciden -----
  80.     ' ----- con la firma que identifica a los ficheros PNG ------
  81.     ' - y que el bloque IHDR está donde debe (en primer lugar). -
  82.     ' -----------------------------------------------------------
  83.  
  84.     IF LEFT$(c$,8)=CHR$(137)+"PNG"+CHR$(13)+CHR$(10)+CHR$(26)+CHR$(10)_
  85.                          AND MID$(c$,13,4)="IHDR" THEN
  86.  
  87.         tmp$="PNG -"
  88.  
  89.         ' ------ Obtaining the image width and height... -----
  90.         ' - Obtención de la anchura y altura de la imagen... -
  91.         ' ----------------------------------------------------
  92.  
  93.         FOR a%=17 TO 24 STEP 4
  94.             char&=0
  95.             FOR d%=0 TO 3
  96.                 char&=char&+ASC(MID$(c$,a%+d%,1))*256^(3-d%)
  97.             NEXT d%
  98.             tmp$=tmp$+STR$(char&)+" x"
  99.         NEXT a%
  100.  
  101.         ' --------------- Obtaining the color depth... ---------------
  102.         ' - Obtención del número de planos (profundidad) de color... -
  103.         ' ------------------------------------------------------------
  104.  
  105.         tmp$=tmp$+STR$(ASC(RIGHT$(c$,1)))
  106.  
  107.         ' ----- The function has did your work... ------
  108.         ' - I refuse the initial failure hypothesis :) -
  109.                 
  110.         ' ------- La función ha tenido éxito... --------
  111.         ' - rechazo la hipótesis inicial de fracaso :) -
  112.         ' ----------------------------------------------
  113.  
  114.         InfoImgFile$=tmp$
  115.  
  116.     ELSE
  117.  
  118.         IF em$="" THEN
  119.  
  120.             ' IoErr()
  121.             LIBRARY OPEN "dos.library",39
  122.  
  123.             ' NewDTObjectA(), GetDTAttribsA(), DisposeDTObject()
  124.             LIBRARY OPEN "datatypes.library",39
  125.  
  126.             ' Pointer to Object struct / Puntero a estructura Object
  127.             o& = NULL&
  128.  
  129.             ' Pointer to BitMapHeader struct / Puntero a estructura BitMapHeader
  130.             b& = NULL&
  131.  
  132.             ' Pointer to Datatype struct / Puntero a estructura Datatype
  133.             d& = NULL&
  134.  
  135.             ' Taglist / Lista de atributos-propiedades para funciones del S.O.
  136.             DIM tags&(3)
  137.  
  138.             ' ---- Tags array for `NewDTObjectA()' (the function awaits -----
  139.             ' -------  a filename and will process only image files) --------
  140.  
  141.             ' - Lista de atributos para `NewDTObjectA()' (la función espera -
  142.             ' - el nombre de un fichero y sólo procesará ficheros gráficos) -
  143.             ' ---------------------------------------------------------------
  144.  
  145.             TAGLIST VARPTR(tags&(0)),_
  146.                 DTA_SourceType&, DTST_FILE&,_
  147.                 DTA_GroupID&, GID_PICTURE&,_
  148.                 TAG_DONE&
  149.  
  150.  
  151.             ' - Creating empty structures as C style with HBasic string function -
  152.             ' ---- and setting pointers to him (`Datatype' & `BitMapHeader') -----
  153.  
  154.             ' --- Creando estructuras vacías al estilo del C con las funciones ---
  155.             ' ----------- de cadena del HBasic y definiendo punteros -------------
  156.             ' -------------- a éstas (`Datatype' & `BitMapHeader') ---------------
  157.             ' --------------------------------------------------------------------
  158.  
  159.             d&=SADD(STRING$(Datatype_sizeof%,CHR$(0)))
  160.             b&=SADD(STRING$(BitMapHeader_sizeof%,CHR$(0)))
  161.  
  162.             IF d& <> NULL& AND b& <> NULL& THEN
  163.  
  164.                 ' ----------- As the "structs" exist I ask my object ----------
  165.                 ' ----------- (the graphic file) for work with this -----------
  166.  
  167.                 ' --- Puesto que las estructuras han sido creadas, solicito ---
  168.                 ' ---- mi objeto (el fichero gráfico) para trabajar con él ----
  169.                 ' -------------------------------------------------------------
  170.  
  171.                 o& = NewDTObjectA&(SADD(fich$+CHR$(0)),VARPTR(tags&(0)))
  172.  
  173.                 IF o& <> NULL& THEN
  174.  
  175.                     ' ------ As the "struct" exists I define a new taglist -------
  176.                     ' --- for GetDTAttrsA& function (I want the image size and ---
  177.                     ' --- depth saved in BitMapHeader struct and the image type --
  178.                     ' ----------- accessible via the Datatype struct). -----------
  179.  
  180.                     ' ----- Puesto que la estructura ha sido creada, preparo -----
  181.                     ' - la nueva lista de atributos para la función GetDTAttrsA& -
  182.                     ' --- (necesito el tamaño de la imagen y su profundidad que --
  183.                     ' ----- están guardados en la estructura BitMapHeader y ------
  184.                     ' -------- el tipo de imagen accesible indirectamente --------
  185.                     ' ------------ a través de la estructura Datatype). ----------
  186.                     ' ------------------------------------------------------------
  187.  
  188.                     TAGLIST VARPTR(tags&(0)),_
  189.                         PDTA_BitMapHeader&, VARPTR(b&),_
  190.                         DTA_Datatype&, VARPTR(d&),_
  191.                         TAG_DONE&
  192.  
  193.  
  194.                     ' ----- I ask the info needed (the function must return ----
  195.                     ' ------------ the number of attribs requested) ------------
  196.  
  197.                     '  --------- Solicito la información que necesito ----------
  198.                     '  - (la función debe devolver el nº de atributos pedidos) -
  199.                     ' ----------------------------------------------------------
  200.  
  201.                     IF GetDTAttrsA&(o&,VARPTR(tags&(0))) = 2 THEN
  202.  
  203.  
  204.                         ' ---------- Prints the info (the image type -----------
  205.                         ' ------------ has four chars as maximum). --------------
  206.  
  207.                         ' -------- Se imprime la información (el tipo -----------
  208.                         ' --- de imagen ocupa cuatro caracteres COMO MÁXIMO). ---
  209.                         ' -------------------------------------------------------
  210.  
  211.                         char& = PEEKL(d&+dtn_Header%)+dth_ID%
  212.  
  213.                         FOR a%=0 TO 3
  214.                         IF UCASE$(CHR$(PEEK(char&+a%)))<>CHR$(0) THEN
  215.                             tmp$=tmp$+UCASE$(CHR$(PEEK(char&+a%)))
  216.                         ELSE
  217.                             EXIT FOR
  218.                         END IF
  219.                         NEXT a%
  220.  
  221.                         tmp$=tmp$+" -"
  222.  
  223.                         tmp$=tmp$+STR$(PEEKW(b&+bmh_Width%))
  224.                         tmp$=tmp$+" x"
  225.                         tmp$=tmp$+STR$(PEEKW(b&+bmh_Height%))
  226.                         tmp$=tmp$+" x"
  227.                         tmp$=tmp$+STR$(PEEK(b&+bmh_Depth%))
  228.  
  229.                         ' ----- The function has did your work... ------
  230.                         ' - I refuse the initial failure hypothesis :) -
  231.                 
  232.                         ' ------- La función ha tenido éxito... --------
  233.                         ' - rechazo la hipótesis inicial de fracaso :) -
  234.                         ' ----------------------------------------------
  235.                         InfoImgFile$=tmp$
  236.  
  237.                     ELSE
  238.  
  239.  
  240.                         ' ------------- Assign the IoErr&() result ------------
  241.                         ' ---------- inmediatly or you will lost this. ---------
  242.  
  243.                         ' --- Asigne el resultado de IoErr&() inmediatamente ---
  244.                         ' -------------- a una variable o lo perderá. ----------
  245.                         ' ------------------------------------------------------
  246.                         en& = IoErr&()
  247.                         em$ = "InfoDTypes$() > GetDTAttrsA&()"
  248.  
  249.                     END IF
  250.  
  251.  
  252.                     ' ---- I've finnished with the object... I release this. ----
  253.  
  254.                     ' -- Hemos terminado con el objeto... así que lo liberamos. --
  255.                     ' ------------------------------------------------------------
  256.                     DisposeDTObject&(o&)
  257.  
  258.                 ELSE
  259.  
  260.                     en& = IoErr&()
  261.                     em$ = "InfoDTypes$() > NewDTObjectA&()"
  262.  
  263.                 END IF
  264.  
  265.             ELSE
  266.  
  267.                 em$="InfoDTypes$(): BitMapHeader/DataType"+CHR$(13)
  268.                 em$=em$+CadLc$(ERROR_NO_MEMORY&)
  269.  
  270.             END IF
  271.     
  272.             LIBRARY CLOSE "dos.library"
  273.             LIBRARY CLOSE "datatypes.library"
  274.  
  275.         END IF
  276.  
  277.     END IF
  278.  
  279. END FUNCTION
  280.